home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / LISP / XLISP / XLISP21S / sources / c / xldmem < prev    next >
Text File  |  1992-04-25  |  22KB  |  917 lines
  1. /* xldmem - xlisp dynamic memory management routines */
  2. /*      Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use       */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* node flags */
  9. #define MARK    0x20
  10. #define LEFT    0x40
  11.  
  12. /* macro to compute the size of a segment */
  13. #define segsize(n) (sizeof(SEGMENT)+((n)-1)*sizeof(struct node))
  14.  
  15. /* external variables */
  16. extern LVAL obarray,s_gcflag,s_gchook,s_unbound,s_debugio,true;
  17. extern LVAL xlenv,xlfenv,xldenv;
  18.  
  19. /* variables local to xldmem.c and xlimage.c */
  20. SEGMENT *segs,*lastseg,*fixseg,*charseg;
  21. int anodes,nsegs;
  22. long gccalls;
  23. long nnodes,nfree,total;
  24. LVAL fnodes = NIL;
  25.  
  26. /* forward declarations */
  27. #ifdef ANSI
  28. #ifdef JMAC
  29. FORWARD LVAL NEAR Newnode(int type);
  30. #else
  31. FORWARD LVAL NEAR newnode(int type);
  32. #endif
  33. FORWARD char * NEAR stralloc(unsigned int size);
  34. FORWARD VOID NEAR mark(LVAL ptr);
  35. FORWARD VOID NEAR sweep(void);
  36. FORWARD VOID NEAR findmem(void);
  37. FORWARD int  NEAR addseg(void);
  38. #else
  39. #ifdef JMAC
  40. FORWARD LVAL Newnode();
  41. #else
  42. FORWARD LVAL newnode();
  43. #endif
  44. FORWARD char *stralloc();
  45. FORWARD VOID mark();
  46. FORWARD VOID sweep();
  47. FORWARD VOID findmem();
  48. #endif
  49.  
  50.  
  51. #ifdef JMAC
  52. LVAL _nnode = NIL;
  53. FIXTYPE _tfixed = 0;
  54. int _tint = 0;
  55.  
  56. #define newnode(type) (((_nnode = fnodes) != NIL) ? \
  57.             ((fnodes = cdr(_nnode)), \
  58.              nfree--, \
  59.              (_nnode->n_type = type), \
  60.              rplacd(_nnode,NIL), \
  61.              _nnode) \
  62.             : Newnode(type))
  63.  
  64. #endif
  65.  
  66. /* $putpatch.c$: "MODULE_XLDMEM_C_GLOBALS" */
  67.  
  68. #ifdef VMEM
  69. LOCAL VOID gcq(size)
  70. long size;
  71. {
  72.     if ((total+size)/VMEM > total/VMEM) gc();
  73. }
  74. #endif
  75.  
  76. /* xlminit - initialize the dynamic memory module */
  77. VOID xlminit()
  78. {
  79.     LVAL p;
  80.     int i;
  81.  
  82.     /* initialize our internal variables */
  83.     segs = lastseg = NULL;
  84.     nnodes = nfree = total = gccalls = 0L;
  85.     nsegs = 0;
  86.     anodes = NNODES;
  87.     fnodes = NIL;
  88.  
  89.     /* allocate the fixnum segment */
  90.     if ((fixseg = newsegment(SFIXSIZE)) == NULL)
  91.         xlfatal("insufficient memory");
  92.  
  93.     /* initialize the fixnum segment */
  94.     p = &fixseg->sg_nodes[0];
  95.     for (i = SFIXMIN; i <= SFIXMAX; ++i) {
  96.         p->n_type = FIXNUM;
  97.         p->n_fixnum = i;
  98.         ++p;
  99.     }
  100.  
  101.     /* allocate the character segment */
  102.     if ((charseg = newsegment(CHARSIZE)) == NULL)
  103.         xlfatal("insufficient memory");
  104.  
  105.     /* initialize the character segment */
  106.     p = &charseg->sg_nodes[0];
  107.     for (i = CHARMIN; i <= CHARMAX; ++i) {
  108.         p->n_type = CHAR;
  109.         p->n_chcode = i;
  110.         ++p;
  111.     }
  112.  
  113.     /* initialize structures that are marked by the collector */
  114.     obarray = NULL;
  115.     xlenv = xlfenv = xldenv = NIL;
  116.     s_gcflag = s_gchook = NULL;
  117.  
  118.     /* $putpatch.c$: "MODULE_XLDMEM_C_XLMINIT" */
  119.  
  120.     /* allocate the evaluation stack */
  121.     xlstack = xlstktop;
  122.  
  123.     /* allocate the argument stack */
  124.     xlfp = xlsp = xlargstkbase;
  125.     *xlsp++ = NIL;
  126.  
  127.     /* we have to make a NIL symbol before continuing */
  128.  
  129.     p = xlmakesym("NIL");
  130.     memcpy(NIL, p, sizeof(struct node));    /* we point to this! */
  131.     defconstant(NIL, NIL);
  132.     p->n_type = FREE;                       /* don't collect "garbage" */
  133.  
  134. }
  135.  
  136. /* cons - construct a new cons node */
  137. LVAL cons(x,y)
  138.   LVAL x,y;
  139. {
  140.     LVAL nnode;
  141.  
  142.     /* get a free node */
  143.     if ((nnode = fnodes) == NIL) {
  144.         xlstkcheck(2);
  145.         xlprotect(x);
  146.         xlprotect(y);
  147.         findmem();
  148.         if ((nnode = fnodes) == NIL)
  149.             xlabort("insufficient node space");
  150.         xlpop();
  151.         xlpop();
  152.     }
  153.  
  154.     /* unlink the node from the free list */
  155.     fnodes = cdr(nnode);
  156.     --nfree;
  157.  
  158.     /* initialize the new node */
  159.     nnode->n_type = CONS;
  160.     rplaca(nnode,x);
  161.     rplacd(nnode,y);
  162.  
  163.     /* return the new node */
  164.     return (nnode);
  165. }
  166.  
  167. /* cvstring - convert a string to a string node */
  168. LVAL cvstring(str)
  169.   char *str;
  170. {
  171.     LVAL val;
  172.     xlsave1(val);
  173.     val = newnode(STRING);
  174.     val->n_strlen = strlen(str);
  175.     val->n_string = stralloc(getslength(val)+1);
  176.     strcpy((char *)getstring(val),str);
  177.     xlpop();
  178.     return (val);
  179. }
  180.  
  181. /* newstring - allocate and initialize a new string */
  182. LVAL newstring(size)
  183.   unsigned size;
  184. {
  185.     LVAL val;
  186.     xlsave1(val);
  187.     val = newnode(STRING);
  188.     val->n_strlen = size;
  189.     val->n_string = stralloc(size+1);
  190.     val->n_string[0] = 0;
  191.     xlpop();
  192.     return (val);
  193. }
  194.  
  195. /* cvsymbol - convert a string to a symbol */
  196. LVAL cvsymbol(pname)
  197.   char *pname;
  198. {
  199.     LVAL val;
  200.     xlsave1(val);
  201.     val = newvector(SYMSIZE);
  202.     val->n_type = SYMBOL;
  203.     setvalue(val,s_unbound);
  204.     setfunction(val,s_unbound);
  205.     setpname(val,cvstring(pname));
  206.     xlpop();
  207.     return (val);
  208. }
  209.  
  210. /* cvsubr - convert a function to a subr or fsubr */
  211. #ifdef ANSI
  212. LVAL cvsubr(LVAL (*fcn)(void), int type, int offset)
  213. #else
  214. LVAL cvsubr(fcn,type,offset)
  215.   LVAL (*fcn)(); int type,offset;
  216. #endif
  217. {
  218.     LVAL val;
  219.     val = newnode(type);
  220.     val->n_subr = fcn;
  221.     val->n_offset = offset;
  222.     return (val);
  223. }
  224.  
  225. /* cvfile - convert a file pointer to a stream */
  226. LVAL cvfile(fp, iomode)
  227.   FILEP fp;
  228.   int  iomode;
  229. {
  230.     LVAL val;
  231.     val = newnode(STREAM);
  232.     setfile(val,fp);
  233.     setsavech(val,'\0');
  234.     val->n_sflags = iomode;
  235.     val->n_cpos = 0;
  236.     return (val);
  237. }
  238.  
  239. #ifdef JMAC
  240.  
  241. /* cvfixnum - convert an integer to a fixnum node */
  242. LVAL Cvfixnum(n)
  243.   FIXTYPE n;
  244. {
  245.     LVAL val;
  246.     val = newnode(FIXNUM);
  247.     val->n_fixnum = n;
  248.     return (val);
  249. }
  250. #else
  251. /* cvfixnum - convert an integer to a fixnum node */
  252. LVAL cvfixnum(n)
  253.   FIXTYPE n;
  254. {
  255.     LVAL val;
  256.     if (n >= SFIXMIN && n <= SFIXMAX)
  257.         return (&fixseg->sg_nodes[(int)n-SFIXMIN]);
  258.     val = newnode(FIXNUM);
  259.     val->n_fixnum = n;
  260.     return (val);
  261. }
  262. #endif
  263.  
  264. /* cvflonum - convert a floating point number to a flonum node */
  265. LVAL cvflonum(n)
  266.   FLOTYPE n;
  267. {
  268.     LVAL val;
  269.     val = newnode(FLONUM);
  270.     val->n_flonum = n;
  271.     return (val);
  272. }
  273.  
  274. /* cvchar - convert an integer to a character node */
  275. #ifdef JMAC
  276. LVAL Cvchar(n)
  277.   int n;
  278. {
  279.     xlerror("character code out of range",cvfixnum((FIXTYPE)n));
  280.     return(NIL);    /* never executed */
  281. }
  282. #else
  283. LVAL cvchar(n)
  284.   int n;
  285. {
  286.     if (n >= CHARMIN && n <= CHARMAX)
  287.         return (&charseg->sg_nodes[n-CHARMIN]);
  288.     xlerror("character code out of range",cvfixnum((FIXTYPE)n));
  289.     return 0;   /* never executed but gets rid of warning message */
  290. }
  291. #endif
  292.  
  293. #ifdef RATIOS
  294. /* cvratio - convert an integer pair to a ratio node */
  295. LVAL cvratio(num, denom)
  296. FIXTYPE num, denom;
  297. {
  298.     LVAL val;
  299.     FIXTYPE n, m, r;
  300.  
  301.     if (num == 0) return cvfixnum((FIXTYPE) 0); /* zero is int zero */
  302.     if (denom < 0) {    /* denominator must be positive */
  303.         denom = -denom;
  304.         num = -num;
  305.     }
  306.     if ((n = num) < 0) n = -n;
  307.     m = denom;  /* reduce the ratio: compute GCD */
  308.     for (;;) {
  309.         if ((r = m % n) == 0) break;
  310.         m = n;
  311.         n = r;
  312.     }
  313.     if (n != 1) {
  314.         denom /= n;
  315.         num /= n;
  316.     }
  317.     if (denom == 1) return cvfixnum(num);   /* reduced to integer */
  318.     val = newnode(RATIO);
  319.     val->n_denom = denom;
  320.     val->n_numer = num;
  321.     return (val);
  322. }
  323. #endif
  324.  
  325. /* newustream - create a new unnamed stream */
  326. LVAL newustream()
  327. {
  328.     LVAL val;
  329.     val = newnode(USTREAM);
  330.     sethead(val,NIL);
  331.     settail(val,NIL);
  332.     return (val);
  333. }
  334.  
  335. /* newobject - allocate and initialize a new object */
  336. LVAL newobject(cls,size)
  337.   LVAL cls; int size;
  338. {
  339.     LVAL val;
  340.     val = newvector(size+1);
  341.     val->n_type = OBJECT;
  342.     setelement(val,0,cls);
  343.     return (val);
  344. }
  345.  
  346. /* newclosure - allocate and initialize a new closure */
  347. LVAL newclosure(name,type,env,fenv)
  348.   LVAL name,type,env,fenv;
  349. {
  350.     LVAL val;
  351.     val = newvector(CLOSIZE);
  352.     val->n_type = CLOSURE;
  353.     setname(val,name);
  354.     settype(val,type);
  355.     setenvi(val,env);
  356.     setfenv(val,fenv);
  357.     return (val);
  358. }
  359.  
  360.  
  361. /* newstruct - allocate and initialize a new structure node */
  362. LVAL newstruct(type,size)
  363.  LVAL type; int size;
  364. {
  365.     LVAL val;
  366.     val = newvector(size+1);
  367.     val->n_type = STRUCT;
  368.     setelement(val,0,type);
  369.     return (val);
  370. }
  371.  
  372.  
  373. /* newvector - allocate and initialize a new vector node */
  374. LVAL newvector(size)
  375.   unsigned size;
  376. {
  377.     LVAL vect;
  378.     int i;
  379.     long bsize = size * sizeof(LVAL *);
  380.  
  381.     if (size > MAXVLEN) xlfail("array too large");
  382.  
  383.     xlsave1(vect);
  384.  
  385.     vect = newnode(VECTOR);
  386.     vect->n_vsize = 0;
  387.  
  388.     if (size != 0) {
  389.         /* We must clear to a nonzero value */
  390. #ifdef VMEM
  391.         gcq(bsize);
  392. #endif
  393.         if ((vect->n_vdata = (LVAL *)MALLOC((unsigned int)bsize)) == NULL) {
  394.             gc();   /*  TAA Mod -- was findmem(), but this would
  395.                         cause undesired memory expansion */
  396.             if ((vect->n_vdata = (LVAL *)MALLOC((unsigned int)bsize)) == NULL)
  397.                 xlfail("insufficient vector space");
  398.         }
  399.         for (i = size; i-- > 0;) setelement(vect, i, NIL);
  400.         vect->n_vsize = size;
  401.         total += bsize;
  402.     }
  403.     xlpop();
  404.     return (vect);
  405. }
  406.  
  407. /* newnode - allocate a new node */
  408. #ifdef JMAC
  409. LOCAL LVAL NEAR Newnode(type)
  410.   int type;
  411. {
  412.     LVAL nnode;
  413.  
  414.     /* get a free node */
  415.     findmem();
  416.     if ((nnode = fnodes) == NIL)
  417.         xlabort("insufficient node space");
  418.  
  419.     /* unlink the node from the free list */
  420.     fnodes = cdr(nnode);
  421.     nfree -= 1L;
  422.  
  423.     /* initialize the new node */
  424.     nnode->n_type = type;
  425.     rplacd(nnode,NIL);
  426.  
  427.     /* return the new node */
  428.     return (nnode);
  429. }
  430. #else
  431. LOCAL LVAL NEAR newnode(type)
  432.   int type;
  433. {
  434.     LVAL nnode;
  435.  
  436.     /* get a free node */
  437.     if ((nnode = fnodes) == NIL) {
  438.         findmem();
  439.         if ((nnode = fnodes) == NIL)
  440.             xlabort("insufficient node space");
  441.     }
  442.  
  443.     /* unlink the node from the free list */
  444.     fnodes = cdr(nnode);
  445.     nfree -= 1L;
  446.  
  447.     /* initialize the new node */
  448.     nnode->n_type = type;
  449.     rplacd(nnode,NIL);
  450.  
  451.     /* return the new node */
  452.     return (nnode);
  453. }
  454. #endif
  455.  
  456. /* stralloc - allocate memory for a string */
  457. LOCAL char * NEAR stralloc(size)
  458.   unsigned int size;
  459. {
  460.     char *sptr;
  461.  
  462. #ifdef VMEM
  463.     gcq((long)size);
  464. #endif
  465.  
  466.     /* allocate memory for the string copy */
  467.     if ((sptr = (char *)MALLOC(size)) == NULL) {
  468.         gc();  
  469.         if ((sptr = (char *)MALLOC(size)) == NULL)
  470.             xlfail("insufficient string space");
  471.     }
  472.     total += (long)size;
  473.  
  474.     /* return the new string memory */
  475.     return (sptr);
  476. }
  477.  
  478. /* findmem - find more memory by collecting then expanding */
  479. LOCAL VOID NEAR findmem()
  480. {
  481.     gc();
  482.     if (nfree < (long)anodes)
  483.         addseg();
  484. }
  485.  
  486. /* gc - garbage collect (only called here and in xlimage.c) */
  487. VOID gc()
  488. {
  489.     register LVAL **p,*ap,tmp;
  490.     FRAMEP newfp;
  491.     LVAL fun;
  492.  
  493.     /* print the start of the gc message */
  494.     if (s_gcflag != NULL && getvalue(s_gcflag) != NIL) {
  495.         /* print message on a fresh line */
  496.         xlfreshline(getvalue(s_debugio));
  497.         sprintf(buf,"[ gc: total %ld, ",nnodes);
  498.         dbgputstr(buf); /* TAA MOD -- was std output */
  499.     }
  500.  
  501.     /* $putpatch.c$: "MODULE_XLDMEM_C_GC" */
  502.  
  503.     /* mark the obarray, the argument list and the current environment */
  504.     if (obarray != NULL)
  505.         mark(obarray);
  506.     if (xlenv != NIL)
  507.         mark(xlenv);
  508.     if (xlfenv != NIL)
  509.         mark(xlfenv);
  510.     if (xldenv != NIL)
  511.         mark(xldenv);
  512.  
  513.     mark(NIL);
  514.  
  515.     /* mark the evaluation stack */
  516.     for (p = xlstack; p < xlstktop; ++p)
  517.         if ((tmp = **p) != NIL)
  518.             mark(tmp);
  519.  
  520.     /* mark the argument stack */
  521.     for (ap = xlargstkbase; ap < xlsp; ++ap)
  522.         if ((tmp = *ap) != NIL)
  523.             mark(tmp);
  524.  
  525.     /* sweep memory collecting all unmarked nodes */
  526.     sweep();
  527.  
  528.     NIL->n_type &= ~MARK;
  529.  
  530.     /* count the gc call */
  531.     ++gccalls;
  532.  
  533.     /* call the *gc-hook* if necessary */
  534.     if (s_gchook != NULL && ((fun = getvalue(s_gchook)) != NIL) ) {
  535.  
  536.         /* rebind hook function to NIL  TAA MOD */
  537.         tmp = xldenv;
  538.         xldbind(s_gchook,NIL);
  539.  
  540.         newfp = xlsp;
  541.         pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  542.         pusharg(fun);
  543.         pusharg(cvfixnum((FIXTYPE)2));
  544.         pusharg(cvfixnum((FIXTYPE)nnodes));
  545.         pusharg(cvfixnum((FIXTYPE)nfree));
  546.         xlfp = newfp;
  547.         xlapply(2);
  548.  
  549.         /* unbind the symbol TAA MOD */
  550.         xlunbind(tmp);
  551.     }
  552.  
  553.     /* print the end of the gc message */
  554.     if (s_gcflag != NULL && getvalue(s_gcflag) != NIL) {
  555.         sprintf(buf,"%ld free ]\n",nfree);
  556.         dbgputstr(buf); /* TAA MOD -- was std output */
  557.     }
  558. }
  559.  
  560. /* mark - mark all accessible nodes */
  561. LOCAL VOID NEAR mark(ptr)
  562.   LVAL ptr;
  563. {
  564.     register LVAL this,prev,tmp;
  565.     int i,n;
  566.     /* initialize */
  567.     prev = NIL;
  568.     this = ptr;
  569.  
  570.     /* mark this list */
  571.     for (;;) {
  572.     /* descend as far as we can */
  573.     while (!(this->n_type & MARK))
  574.   
  575.         /* check cons and unnamed stream nodes */
  576.         if (((i = (this->n_type |= MARK) & TYPEFIELD) == CONS)||
  577.             (i == USTREAM)) {
  578.             if ((tmp = car(this)) != NIL) {
  579.                 this->n_type |= LEFT;
  580.                 rplaca(this,prev);
  581.             }
  582.             else if ((tmp = cdr(this)) != NIL)
  583.                 rplacd(this,prev);
  584.             else                /* both sides nil */
  585.                 break;
  586.             prev = this;            /* step down the branch */
  587.             this = tmp;
  588.         }
  589.         /* $putpatch.c$: "MODULE_XLDMEM_C_MARK" */
  590.         else {
  591.             if ((i & ARRAY) != 0)
  592.                 for (i = 0, n = getsize(this); i < n;)
  593.                     if ((tmp = getelement(this,i++)) != NIL)
  594.                         if ((tmp->n_type & (ARRAY|MARK)) == ARRAY ||
  595.                             tmp->n_type == CONS ||
  596.                             tmp->n_type == USTREAM)
  597.                             mark(tmp);
  598.                         else tmp->n_type |= MARK;
  599.                         break;
  600.         }
  601.  
  602.         /* backup to a point where we can continue descending */
  603.         for (;;)
  604.  
  605.             /* make sure there is a previous node */
  606.             if (prev != NIL) {
  607.                 if (prev->n_type & LEFT) {      /* came from left side */
  608.                     prev->n_type &= ~LEFT;
  609.                     tmp = car(prev);
  610.                     rplaca(prev,this);
  611.                     if ((this = cdr(prev)) != NIL) {
  612.                         rplacd(prev,tmp);                       
  613.                         break;
  614.                     }
  615.                 }
  616.                 else {                          /* came from right side */
  617.                     tmp = cdr(prev);
  618.                     rplacd(prev,this);
  619.                 }
  620.                 this = prev;                    /* step back up the branch */
  621.                 prev = tmp;
  622.             }
  623.             /* no previous node, must be done */
  624.             else
  625.                 return;
  626.     }
  627. }
  628.  
  629. /* sweep - sweep all unmarked nodes and add them to the free list */
  630. LOCAL VOID NEAR sweep()
  631. {
  632.     SEGMENT *seg;
  633.     LVAL p;
  634.     int n;
  635.  
  636.     /* empty the free list */
  637.     fnodes = NIL;
  638.     nfree = 0L;
  639.  
  640.     /* add all unmarked nodes */
  641.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  642.         if (seg == fixseg || seg == charseg) {
  643.             /* remove marks from segments */
  644.             p = &seg->sg_nodes[0];
  645.             for (n = seg->sg_size; --n >= 0;)
  646.                 (p++)->n_type &= ~MARK;
  647.             continue;
  648.         }
  649.         p = &seg->sg_nodes[0];
  650.  
  651.         for (n = seg->sg_size; --n >= 0;)
  652.             if (p->n_type & MARK)
  653.                 (p++)->n_type &= ~MARK;
  654.             else {
  655.                 switch (ntype(p)&TYPEFIELD) {
  656.                 case STRING:
  657.                         if (getstring(p) != NULL) {
  658.                             total -= (long)getslength(p)+1;
  659.                             MFREE(getstring(p));
  660.                         }
  661.                         break;
  662.                 case STREAM:
  663.                         if (getfile(p) != CLOSED
  664.                             && getfile(p) != STDIN
  665.                             && getfile(p) != STDOUT
  666.                             && getfile(p) != CONSOLE)/* taa fix - dont close stdio */
  667.                             OSCLOSE(getfile(p));
  668.                         break;
  669.         /* $putpatch.c$: "MODULE_XLDMEM_C_SWEEP" */
  670.                 case SYMBOL:
  671.                 case OBJECT:
  672.                 case VECTOR:
  673.                 case CLOSURE:
  674.                 case STRUCT:
  675. #ifdef COMPLX
  676.                 case COMPLEX:
  677. #endif
  678.                         if (p->n_vsize) {
  679.                             total -= (long)p->n_vsize * sizeof(LVAL);
  680.                             MFREE(p->n_vdata);
  681.                         }
  682.                         break;
  683.                 }
  684.                 p->n_type = FREE;
  685.                 rplaca(p,NIL);
  686.                 rplacd(p,fnodes);
  687.                 fnodes = p++;
  688.                 nfree++;
  689.             }
  690.     }
  691. }
  692.  
  693. /* addseg - add a segment to the available memory */
  694. LOCAL int NEAR addseg()
  695. {
  696.     SEGMENT *newseg;
  697.     LVAL p;
  698.     int n;
  699.  
  700.     /* allocate the new segment */
  701.     if (anodes == 0 || (newseg = newsegment(anodes)) == NULL)
  702.         return (FALSE);
  703.  
  704.     /* add each new node to the free list */
  705.     p = &newseg->sg_nodes[0];
  706.     for (n = anodes; --n >= 0; ++p) {
  707.         rplacd(p,fnodes);
  708.         fnodes = p;
  709.     }
  710.     
  711.     /* return successfully */
  712.     return (TRUE);
  713. }
  714.  
  715. /* newsegment - create a new segment (only called here and in xlimage.c) */
  716. SEGMENT *newsegment(n)
  717.   int n;
  718. {
  719.     SEGMENT *newseg;
  720.  
  721.     /* allocate the new segment */
  722.     if ((newseg = (SEGMENT *)CALLOC(1,segsize(n))) == NULL)
  723.         return (NULL);
  724.  
  725.     /* initialize the new segment */
  726.     newseg->sg_size = n;
  727.     newseg->sg_next = NULL;
  728.     if (segs != NULL)
  729.         lastseg->sg_next = newseg;
  730.     else
  731.         segs = newseg;
  732.     lastseg = newseg;
  733.  
  734.     /* update the statistics */
  735.     total += (long)segsize(n);
  736.     nnodes += (long)n;
  737.     nfree += (long)n;
  738.     ++nsegs;
  739.  
  740.     /* return the new segment */
  741.     return (newseg);
  742. }
  743.  
  744. /* stats - print memory statistics */
  745. #ifdef ANSI
  746. static void NEAR stats(void)
  747. #else
  748. LOCAL VOID stats()
  749. #endif
  750. {
  751.     sprintf(buf,"Nodes:       %ld\n",nnodes); stdputstr(buf);
  752.     sprintf(buf,"Free nodes:  %ld\n",nfree);  stdputstr(buf);
  753.     sprintf(buf,"Segments:    %d\n",nsegs);   stdputstr(buf);
  754.     sprintf(buf,"Allocate:    %d\n",anodes);  stdputstr(buf);
  755.     sprintf(buf,"Total:       %ld\n",total);  stdputstr(buf);
  756.     sprintf(buf,"Collections: %ld\n",gccalls); stdputstr(buf);
  757. }
  758.  
  759. /* xgc - xlisp function to force garbage collection */
  760. LVAL xgc()
  761. {
  762.     /* make sure there aren't any arguments */
  763.     xllastarg();
  764.  
  765.     /* garbage collect */
  766.     gc();
  767.  
  768.     /* return nil */
  769.     return (NIL);
  770. }
  771.  
  772. /* xexpand - xlisp function to force memory expansion */
  773. LVAL xexpand()
  774. {
  775.     LVAL num;
  776.     FIXTYPE n,i;
  777.  
  778.     /* get the new number to allocate */
  779.     if (moreargs()) {
  780.         num = xlgafixnum();
  781.         n = getfixnum(num);
  782.         /* make sure there aren't any more arguments */
  783.         xllastarg();
  784.     }
  785.     else
  786.         n = 1;
  787.  
  788.     /* allocate more segments */
  789.     for (i = 0; i < n; i++)
  790.         if (!addseg())
  791.             break;
  792.  
  793.     /* return the number of segments added */
  794.     return (cvfixnum((FIXTYPE)i));
  795. }
  796.  
  797. /* xalloc - xlisp function to set the number of nodes to allocate */
  798. LVAL xalloc()
  799. {
  800.     FIXTYPE n;  /* TAA MOD -- prevent overflow */
  801.     int oldn;
  802.  
  803.     /* get the new number to allocate */
  804.     n = getfixnum(xlgafixnum());    
  805.  
  806.     /* make sure there aren't any more arguments */
  807.     if (xlargc > 1) xltoomany();    /* but one more is OK, TAA MOD */
  808.  
  809.     /* Place limits on argument by clipping to reasonable values  TAA MOD */
  810.     if (n > ((long)MAXSLEN - sizeof(SEGMENT))/sizeof(struct node)) 
  811.         n = ((long)MAXSLEN - sizeof(SEGMENT))/sizeof(struct node);
  812.     else if (n < 1000) 
  813.         n = 1000;   /* arbitrary */
  814.  
  815.     /* set the new number of nodes to allocate */
  816.     oldn = anodes;
  817.     anodes = (int)n;
  818.  
  819.     /* return the old number */
  820.     return (cvfixnum((FIXTYPE)oldn));
  821. }
  822.  
  823. /* xmem - xlisp function to print memory statistics */
  824. LVAL xmem()
  825. {
  826.     /* allow one argument for compatiblity with common lisp */
  827.     if (xlargc > 1) xltoomany();    /* TAA Mod */
  828.  
  829.     /* print the statistics */
  830.     stats();
  831.  
  832.     /* return nil */
  833.     return (NIL);
  834. }
  835.  
  836. #ifdef SAVERESTORE
  837. /* xsave - save the memory image */
  838. LVAL xsave()
  839. {
  840.     char *name;
  841.  
  842.     /* get the file name, verbose flag and print flag */
  843.     name = getstring(xlgetfname());
  844.     xllastarg();
  845.  
  846.     /* save the memory image */
  847.     return (xlisave(name) ? true : NIL);
  848. }
  849.  
  850. /* xrestore - restore a saved memory image */
  851. LVAL xrestore()
  852. {
  853.     extern jmp_buf top_level;
  854.     char *name;
  855.  
  856.     /* get the file name, verbose flag and print flag */
  857.     name = getstring(xlgetfname());
  858.     xllastarg();
  859.  
  860.     /* restore the saved memory image */
  861.     if (!xlirestore(name))
  862.         return (NIL);
  863.  
  864.     /* return directly to the top level */
  865.     dbgputstr("[ returning to the top level ]\n");  /* TAA MOD --was std out*/
  866.     longjmp(top_level,1);
  867.     return (NIL);   /* never executed, but avoids warning message */
  868. }
  869.  
  870. #endif
  871.  
  872. #ifdef COMPLX
  873. /* From XLISP-STAT, Copyright (c) 1988 Luke Tierney */
  874.  
  875. LVAL newicomplex(real, imag)
  876.         FIXTYPE real, imag;
  877. {
  878.   LVAL val;
  879.   
  880.   if (imag == 0) val = cvfixnum(real);
  881.   else {
  882.     xlsave1(val);
  883.     val = newvector(2);
  884.     val->n_type = COMPLEX;
  885.     setelement(val, 0, cvfixnum(real));
  886.     setelement(val, 1, cvfixnum(imag));
  887.     xlpop();
  888.   }
  889.   return(val);
  890. }
  891.  
  892. LVAL newdcomplex(real, imag)
  893.         double real, imag;
  894. {
  895.   LVAL val;
  896.   
  897.   xlsave1(val);
  898.   val = newvector(2);
  899.   val->n_type = COMPLEX;
  900.   setelement(val, 0, cvflonum((FLOTYPE) real));
  901.   setelement(val, 1, cvflonum((FLOTYPE) imag));
  902.   xlpop();
  903.   return(val);
  904. }
  905.  
  906. /* newcomplex - allocate and initialize a new object */
  907. LVAL newcomplex(real,imag)
  908.   LVAL real,imag;
  909. {
  910.   if (fixp(real) && fixp(imag))
  911.     return(newicomplex(getfixnum(real), getfixnum(imag)));
  912.   else
  913.     return(newdcomplex(makefloat(real), makefloat(imag)));
  914. }
  915.  
  916. #endif
  917.